home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
faq-s.zip
/
VIDEO.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-02-04
|
4KB
|
205 lines
Unit VIDEO;
interface
uses Dos,crt;
type
screenchars = record
ch : char;
at : byte;
end;
screens = record
position : array[1..25,1..80] of ScreenChars;
x,y : byte;
end;
screenType = (mono,color);
var
stype : screentype;
vidseg : word;
procedure showscreen(var source, video; length : word);
procedure getscreen(var video,source; length: word);
procedure xystring(x,y : byte;s : string;fg,bg : byte);
procedure readscr(var S);
procedure writescr(var s);
procedure horstr(x,y,len : byte;fg,bg : byte;ch : char);
procedure verstr(x,y,len : byte;fg,bg : byte;ch : char);
procedure box(x1,y1,x2,y2 : byte;fg,bg : byte);
procedure center(y : byte;st : string;fg,bg :byte);
procedure boxstring(y:byte;st : string;fg,bg : byte);
procedure fillscreen(var sc : screens;s : string;x,y:byte;fg,bg : byte);
procedure cursoroff;procedure cursorsmall;procedure cursorbig;
implementation
var
regs : registers;
vid : pointer;
procedure showscreen(var source,video;length : word);
begin
if stype = color then
Inline($90/$90/$90/$90/
$1E/$55/$BA/$DA/$03/$C5/$B6/ SOURCE /$C4/$BE/ VIDEO /
$8B/$8E/ LENGTH /$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/
$82/$FB/$FA/$EC/$20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/
$EA/$5D/$1F)
ELSE
BEGIN
length := length * 2;
move(source,video,length);
end;
end;
procedure GetScreen(var video,source;length : word);
begin
if stype = color then
inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Video /$C4/$BE/ Source /
$8B/$8E/Length/$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/
$D8/$73/$FB/$AD/$FB/$AB/$E2/$F0/$5D/$1F)
ELSE
BEGIN
length := length * 2;
move(source,video,length);
end;
end;
PROCEDURE XYSTRING(X,Y:BYTE;S:STRING;FG,BG:BYTE);
VAR
sa : array[1..255] of record
ch : char;
at : byte;
end;
b,i : byte;
offset : word;
begin
if (length(s) = 0) or
(x>80) or (x<1) or (y>25) or (y<1) then exit;
b := (ord(bg shl 4)) or ord(fg);
fillchar(sa,sizeof(sa),b);
for i := 1 to length(s) do sa[i].ch := s[i];
offset := (((y-1)*80)+(x-1))*2;
vid := ptr(vidseg,offset);
showscreen(sa,vid^,length(s));
end;
procedure readscr(var s);
begin
vid := ptr(vidseg,0);
getscreen(vid^,s,2000);
end;
procedure writescr(var s);
begin
vid := ptr(vidseg,0);
showscreen(s,vid^,2000);
end;
procedure horstr(x,y,len:byte;fg,bg : byte;ch : char);
var
i : byte;
begin
for i := 1 to len do
begin
xystring(x,y,ch,fg,bg);
x := x + 1;
end;
end;
procedure verstr(x,y,len,fg,bg : byte;ch : char);
var
i : byte;
begin
for i := 1 to len do
begin
xystring(x,y,ch,fg,bg);
y := y + 1;
end;
end;
procedure box(x1,y1,x2,y2 : byte;
fg,bg : byte);
begin
if (x1<1) or (x2>80) or (y1<1) or (y2>25) or ((x2 -x1)<2) or ((y2-y1)<2)
then exit;
horstr(x1,y1,1,fg,bg,#201);
horstr(x2,y1,1,fg,bg,#187);
horstr(x1,y2,1,fg,bg,#200);
horstr(x2,y2,1,fg,bg,#188);
verstr(x1,y1+1,y2-y1-1,fg,bg,#186);
verstr(x2,y1+1,y2-y1-1,fg,bg,#186);
horstr(x1+1,y1,x2-x1-1,fg,bg,#205);
horstr(x1+1,y2,x2-x1-1,fg,bg,#205);
end;
procedure center(y:byte;st : string;fg,bg : byte);
var
x : byte;
begin
x := (40-(length(st) div 2));
xystring(x,y,st,fg,bg);
end;
procedure boxstring(y:byte;st : string;fg,bg : byte);
var
x1,y1,x2,y2 : byte;
begin
center(y,st,fg,bg);
x1 := 40-(length(st) div 2)-2;
x2 := x1 + length(st) + 3;
y1 := y - 1;
y2 := y + 1;
box(x1,y1,x2,y2,fg,bg);
end;
procedure fillscreen(var sc : screens;s : string;x,y,fg,bg : byte);
var
i,atx : byte;
begin
atx := fg or (bg shl 4);
for i := 1 to length(s) do
begin
sc.position[y,x].ch := s[i];
sc.position[y,x].at := atx;
x :=x+1;
if x > 80 then
begin
x := 1;
y := y + 1;
if y > 25 then
exit;
end;
end;
end;
procedure cursoroff;
begin
fillchar(regs,sizeof(regs),0);
with regs do
begin
ah := $01;
ch := $20;
cl := $20;
end;
intr($10,regs);
end;
procedure cursorsmall;
begin
fillchar(regs,sizeof(regs),0);
regs.ah := $01;
case stype of
mono : begin
with regs do begin ch:=12;cl :=13;end;end;
color : begin
with regs do begin ch := 6;cl := 7;end;end;end;
intr($10,regs);
end;
procedure cursorbig;
begin
fillchar(regs,sizeof(regs),0);
regs.ah :=1;
regs.ch :=0;
case stype of
mono : regs.cl := 13;
color : regs.cl := 7;
end;
intr($10,regs);end;
begin
fillchar(regs,sizeof(regs),0);
regs.ah := $0F;
intr($10,regs);
if regs.al = 7 then begin
stype := mono;
vidseg := $B000;
end
else
begin
stype := color;
vidseg := $B800;
end;
end.